home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / lib / tcl / init.tcl < prev    next >
Encoding:
Text File  |  1992-07-25  |  4.1 KB  |  155 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # $Header: /user6/ouster/tcl/scripts/RCS/init.tcl,v 1.7 92/07/25 16:29:36 ouster Exp $ SPRITE (Berkeley)
  7. #
  8. # Copyright 1991-1992 Regents of the University of California
  9. # Permission to use, copy, modify, and distribute this
  10. # software and its documentation for any purpose and without
  11. # fee is hereby granted, provided that this copyright
  12. # notice appears in all copies.  The University of California
  13. # makes no representations about the suitability of this
  14. # software for any purpose.  It is provided "as is" without
  15. # express or implied warranty.
  16. #
  17.  
  18. # unknown:
  19. # Invoked when a Tcl command is invoked that doesn't exist in the
  20. # interpreter:
  21. #
  22. #    1. See if the autoload facility can locate the command in a
  23. #       Tcl script file.  If so, load it and execute it.
  24. #    2. See if the command exists as an executable UNIX program.
  25. #       If so, "exec" the command.
  26. #    3. See if the command is a valid abbreviation for another command.
  27. #       if so, invoke the command.  However, only permit abbreviations
  28. #       at top-level.
  29.  
  30. proc unknown args {
  31.     global auto_noexec auto_noload env unknown_active
  32.  
  33.     if [info exists unknown_active] {
  34.     unset unknown_active
  35.     error "unexpected recursion in \"unknown\" command"
  36.     }
  37.     set unknown_active 1
  38.     set name [lindex $args 0]
  39.     if ![info exists auto_noload] {
  40.     if [auto_load $name] {
  41.         unset unknown_active
  42.         return [uplevel $args]
  43.     }
  44.     }
  45.     if ![info exists auto_noexec] {
  46.     if [auto_execok $name] {
  47.         unset unknown_active
  48.         return [uplevel exec $args]
  49.     }
  50.     }
  51.     if {([info level] == 1) && ([info script] == "")} {
  52.     set cmds [info commands $name*]
  53.     if {[llength $cmds] == 1} {
  54.         unset unknown_active
  55.         return [uplevel [lreplace $args 0 0 $cmds]]
  56.     }
  57.     if {[llength $cmds] != 0} {
  58.         unset unknown_active
  59.         if {$name == ""} {
  60.         error "empty command name \"\""
  61.         } else {
  62.         error "ambiguous command name \"$name\": [lsort $cmds]"
  63.         }
  64.     }
  65.     }
  66.     unset unknown_active
  67.     error "invalid command name \"$name\""
  68. }
  69.  
  70. # auto_load:
  71. # Checks a collection of library directories to see if a procedure
  72. # is defined in one of them.  If so, it sources the appropriate
  73. # library file to create the procedure.  Returns 1 if it successfully
  74. # loaded the procedure, 0 otherwise.
  75.  
  76. proc auto_load cmd {
  77.     global auto_index auto_oldpath auto_path env
  78.  
  79.     if [info exists auto_index($cmd)] {
  80.     uplevel #0 source $auto_index($cmd)
  81.     return 1
  82.     }
  83.     if [catch {set path $auto_path}] {
  84.     if [catch {set path $env(TCLLIBPATH)}] {
  85.         if [catch {set path [info library]}] {
  86.         return 0
  87.         }
  88.     }
  89.     }
  90.     if [info exists auto_oldpath] {
  91.     if {$auto_oldpath == $path} {
  92.         return 0
  93.     }
  94.     }
  95.     set auto_oldpath $path
  96.     catch {unset auto_index}
  97.     foreach dir $path {
  98.     set f ""
  99.     catch {
  100.         set f [open $dir/tclIndex]
  101.         if {[gets $f] != "# Tcl autoload index file: each line identifies a Tcl"} {
  102.         puts stdout "Bad id line in file $dir/tclIndex"
  103.         error done
  104.         }
  105.         while {[gets $f line] >= 0} {
  106.         if {([string index $line 0] == "#") || ([llength $line] != 2)} {
  107.             continue
  108.         }
  109.         set name [lindex $line 0]
  110.         if {![info exists auto_index($name)]} {
  111.             set auto_index($name) $dir/[lindex $line 1]
  112.         }
  113.         }
  114.     }
  115.     if {$f != ""} {
  116.         close $f
  117.     }
  118.     }
  119.     if [info exists auto_index($cmd)] {
  120.     uplevel #0 source $auto_index($cmd)
  121.     return 1
  122.     }
  123.     return 0
  124. }
  125.  
  126. # auto_execok:
  127. # Returns 1 if there's an executable in the current path for the
  128. # given name, 0 otherwise.  Builds an associative array auto_execs
  129. # that caches information about previous checks, for speed.
  130.  
  131. proc auto_execok name {
  132.     global auto_execs env
  133.  
  134.     if [info exists auto_execs($name)] {
  135.     return $auto_execs($name)
  136.     }
  137.     set auto_execs($name) 0
  138.     foreach dir [split $env(PATH) :] {
  139.     if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
  140.         set auto_execs($name) 1
  141.         return 1
  142.     }
  143.     }
  144.     return 0
  145. }
  146.  
  147. # auto_reset:
  148. # Destroy all cached information for auto-loading and auto-execution,
  149. # so that the information gets recomputed the next time it's needed.
  150.  
  151. proc auto_reset {} {
  152.     global auto_execs auto_index
  153.     unset auto_execs auto_index
  154. }
  155.